;;;; -*-Mode: Lisp; Syntax: Common-Lisp; fill-column: 76; -*-

;;;; autoload.lisp -- Autoloader for Corman Lisp.

;;;; Copyright (C) 1999 Vassili Bykov.

;;;; Author:       Vassili Bykov <vassili@objectpeople.com>
;;;; Created:      01/09/1999
;;;; Last updated: 01/10/1999
;;;;
;;;; History:		10/13/99  RGC  Modified LOAD-AUTOLOAD-MODULE to 
;;;;							   look for a compiled (FASL) file first.
;;;;


(in-package :cormanlisp)

(export '(*QUIET-AUTOLOAD*
	  DEFINE-AUTOLOADED-MODULE
	  QUASILOAD))

;; When true, no information messages ("Autoloading ...") are printed on the
;; *standard-output* when an autoload is invoked.
;;
(defvar *quiet-autoload* nil)

;;; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;; IMPLEMENTATION OVERVIEW.  All functions declared as autoloadable get an
;;; "autoload thunk" installed as their function definition.  This applies
;;; to both regular functions and macro expanders.  The thunk is a closure
;;; holding onto the symbol and an "autoload descriptor".  An autoload
;;; descriptor is a structure keeping the details of the pending load
;;; operation.  In addition to being closed over by a thunk, it is also put
;;; onto the symbol's property list as 'AUTOLOAD property, to easily detect
;;; descriptor conflicts (attempts to autoload a symbol from several
;;; sources).  When a thunk is invoked (as the result of calling the
;;; function or macroexpanding a form), it loads the file identified by the
;;; autoload descriptor, then checks that the functions of all the symbols
;;; that were supposed to be loaded by the descriptor has been redefined,
;;; reporting those that haven't been.  (Meaning the loaded module failed to
;;; actually define them).  Those symbols receive a "dead autoload thunk" as
;;; their function definition.  If invoked, that thunk signals an error with
;;; the explanation of what autoloadable module it was that failed to define
;;; the called function.
;;; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

(defstruct (autoload-descriptor
	     (:constructor make-autoload-descriptor (file-name
						     root-symbol
						     functions
						     macros)))
  ;; When this descriptor is loaded, FILE-NAME is appended to the value of
  ;; ROOT-SYMBOL at the time of the load to obtain the (supposedly absolute)
  ;; name of the file to load.  The default root is the Corman Lisp
  ;; installation directory.
  file-name
  root-symbol
  ;; Lists of symbols that are supposed to be defined as functions and
  ;; macros by this module.
  functions
  macros)

(defun autoload-descriptor-symbols-map (function descriptor)
  (let ((results nil))
    (dolist (sym (autoload-descriptor-functions descriptor))
      (push (funcall function sym) results))
    (dolist (sym (autoload-descriptor-macros descriptor))
      (push (funcall function sym) results))
    (nreverse results)))

(defmacro autoload-descriptor-symbols-do ((var desc-form) &body forms)
  (let ((dsym (gensym))
	(fsym (gensym)))
    `(LET ((,dsym ,desc-form))
      (FLET ((,fsym (,var) ,@forms))
	(MAPC #',fsym (AUTOLOAD-DESCRIPTOR-FUNCTIONS ,dsym))
	(MAPC #',fsym (AUTOLOAD-DESCRIPTOR-MACROS ,dsym))))))

(defun make-dead-autoload-thunk (symbol descriptor)
	#'(lambda (&rest args)
		(declare (ignore args))
		(error "The function ~S is not defined.  It was declared as ~
              autoloadable, but not defined while autoloading ~S."
			symbol descriptor)))

;; Make sure that all of the symbols about to be autoloaded using the
;; DESCRIPTOR are OK, whatever that means.  Return a list of the original
;; function bindings of all the symbols, for future use by VERIFY-AUTOLOAD.
;;
(defun validate-autoload (descriptor)
  ;; Can't think of a *reasonable* validation for now.
  (autoload-descriptor-symbols-map
   #'symbol-function
   descriptor))

;; Accept a list of original function bindings generated by the previous
;; call to VALIDATE-AUTOLOAD and make sure all of the functions have been
;; loaded (i.e redefined).  Report as a warning those that haven't been.
;;
(defun verify-autoload (orig-functions descriptor)
  (autoload-descriptor-symbols-do (sym descriptor)
    (when (eq (car orig-functions) (symbol-function sym))
      ;; Replace with a continuable error when exceptions are in place
      (format t "~&;;; Warning: The function of symbol ~S has not been ~
                 defined by autoloading ~S.~%"
	      sym descriptor)
      (setf (symbol-function sym)
	    (make-dead-autoload-thunk sym descriptor)))
    (pop orig-functions)))

(defun module-filename (prefix filename)
  (cond ((not prefix)
	 filename)
	((or (and (> (length prefix) 1)
		  (member (char prefix (1- (length prefix))) '(#\\ #\/)))
	     (member (char filename 0) '(#\\ #\/)))
	 (concatenate 'string prefix filename))
	(t
	 (concatenate 'string prefix "\\" filename))))

(defconstant lisp-src-extension "lisp")
(defconstant lisp-binary-extension "fasl")

(defun binary-equivalent (path)
	(let ((len (length path)))
		(if (and (> len (length lisp-src-extension)) 
				(string-equal 
					(subseq path (- len (length lisp-src-extension)) len) 
					lisp-src-extension))
			(concatenate 'string (subseq path 0 (- len (length lisp-src-extension)))
				lisp-binary-extension))))

(defun load-autoload-module (descriptor)
	(let ((*package* *package*)
		  (path (module-filename (symbol-value
				(autoload-descriptor-root-symbol descriptor))
			       (autoload-descriptor-file-name descriptor))))
		(let ((binary-path (binary-equivalent path)))
			(if (probe-file binary-path)
				(setf path binary-path)))
		(unless *quiet-autoload* (format t "~&;;; Autoloading ~A ...~%" path))
		(load path)))

(defun cleanup-autoload (descriptor)
  (autoload-descriptor-symbols-do (sym descriptor)
    (remprop sym 'autoload)))

(defun make-autoload-thunk (symbol descriptor)
  (let ((old-descriptor (get symbol 'autoload)))
    (when (and old-descriptor
	       (string-not-equal
		(autoload-descriptor-file-name descriptor)
		(autoload-descriptor-file-name old-descriptor)))
      ;; Replace with a continuable error when exceptions are in place
      (format t "~&;;; WARNING: Overriding autoload descriptor of symbol ~
                 ~S. Old descriptor: ~S. New descriptor: ~S.~%"
	      symbol old-descriptor descriptor)))
  #'(lambda (&rest call-args)
      (let ((original-funs (validate-autoload descriptor)))
	(load-autoload-module descriptor)
	(verify-autoload original-funs descriptor)
	(cleanup-autoload descriptor)
	;; and, finally,
	(apply (symbol-function symbol) call-args))))

;;; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;; Macro: DEFINE-AUTOLOADED-MODULE
;;; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

(defun parse-autoload-options (options)
  ;; => (VALUES root-sym function-syms macro-syms)
  (let ((root-sym :unset)
	(function-syms nil)
	(macro-syms nil))
    (dolist (option options)
      (unless (and (listp option) (keywordp (car option)))
	(error "Invalid autoload option: ~S" option))
      (case (car option)
	(:root
	 (unless (or (eq root-sym :unset) (eq root-sym (second option)))
	   (error "Conflicting :root settings."))
	 (let ((root (second option)))
	   (unless (symbolp root)
	     (error "Invalid :root setting: ~S" root))
	   (setq root-sym root)))
	(:functions
	 (dolist (fun (cdr option))
	   (unless (symbolp fun)
	     (error "Invalid function symbol: ~S" fun))
	   (when (member fun macro-syms)
	     (error "Symbol ~S is declared as both a macro and a function"
		    fun))
	   (pushnew fun function-syms)))
	(:macros
	 (dolist (mac (cdr option))
	   (unless (symbolp mac)
	     (error "Invalid macro name: ~S" mac))
	   (when (member mac function-syms)
	     (error "Symbol ~S is declared as both a macro and a function"
		    mac))
	   (pushnew mac macro-syms)))))
    (values (if (eq root-sym :unset) '*cormanlisp-directory* root-sym)
	    function-syms
	    macro-syms)))


(defmacro define-autoloaded-module (file-name &rest options)
  (unless (and (stringp file-name) (> (length file-name) 0))
    (error "Invalid autoload file name: ~S" file-name))
  (multiple-value-bind (root-sym functions macros)
      (parse-autoload-options options)
    (let ((descriptor (gensym)))
      `(LET ((,descriptor (MAKE-AUTOLOAD-DESCRIPTOR
			   ,file-name
			   ',root-sym
			   ',functions
			   ',macros)))
	,@(mapcar
	   #'(lambda (sym)
	       `(SETF (SYMBOL-FUNCTION ',sym)
		      (MAKE-AUTOLOAD-THUNK ',sym ,descriptor)))
	   functions)
	,@(mapcar
	   #'(lambda (sym)
	       `(CL::SET-SYMBOL-MACRO
		 (MAKE-AUTOLOAD-THUNK ',sym ,descriptor)
		 ',sym))
	   macros)
	(AUTOLOAD-DESCRIPTOR-SYMBOLS-DO (SYM ,descriptor)
	 (SETF (GET SYM 'AUTOLOAD) ,descriptor))
	,file-name))))

;;; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;; Function: QUASILOAD
;;; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

(defun quasiload-file (stream)
	(declare (ignore stream))
  ;; => (VALUES function-symbols macro-symbols)
  (let ((eof (cons nil nil))
	(functions nil)
	(macros nil))
    (labels ((quasiload-form (form)
	       (case (car form)
		 (DEFUN
		  (let ((function-name (second form)))
		    (cond ((symbolp function-name)
			   (push function-name functions)))))
		 (DEFMACRO
		  (let ((macro-name (second form)))
		    (cond ((symbolp macro-name)
			   (push macro-name macros)))))
		 (IN-PACKAGE
		  (setq *package* (second form)))
		 (EXPORT
		  (cond ((and (listp (second form))
			      (eq 'QUOTE (first (second form))))
			 (export (second (second form))))))
		 ((PROGN PROG1 PROG2)
		  (dolist (f (cdr form))
		    (quasiload-form f)))
		 ((EVAL-WHEN LET LET*)
		  (dolist (f (cddr form))
		    (quasiload-form f))))))
      (do ((top-form (read stream nil eof) (read stream nil eof)))
	  ((eq top-form eof))
	(quasiload-form top-form)))
    (values functions macros)))

(defun quasiload (file-name &key root)
  (let ((*package* *package*))
    (with-open-file (file file-name
			  :direction :input
			  :if-does-not-exist :error)
      (multiple-value-bind (functions macros)
	  (quasiload-file file)
	(let ((descriptor
	       (make-autoload-descriptor file-name
					 (or root
					     '*cormanlisp-directory*)
					 functions
					 macros)))
	  (dolist (sym functions)
	    (setf (symbol-function sym)
		  (make-autoload-thunk sym descriptor)))
	  (dolist (sym macros)
	    (cl::set-symbol-macro (make-autoload-thunk sym descriptor)
				  sym))
	  (autoload-descriptor-symbols-do (sym descriptor)
	    (setf (get sym 'autoload) descriptor))
	  descriptor)))))

